Shareware Grab Bag/Shareware Grab Bag.iso/090/listsubs.arc/LISTSUBS.PAS

Pascal/Delphi Source File | 1986-01-19 | 5.5 KB | 199 lines

program listSubs;

{
This program prints a listing of all procedure and function
declarations in a Pascal source  program.

Author: Fritz Ziegler
Date: 7/15/84, modified 1/19/86
Application: All systems
Originally published in TUG Lines (Turbo User Group) Vol. 1, Issue 5
}

type
  fil_type = text;
  filname_type = string[14]; { x:yyyyyyyy.zzz }
  fil_lin_type = string[255];
  maxstring = string[255];
  identifier_type = string[127];

var
  fil : fil_type;
  outfil : fil_type;
  filname : filname_type;
  outfilname : filname_type;
  done,
  error : boolean;

procedure close_files(var fil,outfil:fil_type);
begin
  close(fil);
  close(outfil);
end; { close_files }

procedure upc_filname(var filname:filname_type);
  var
    i : integer;
begin
  for i := 1 to length(filname) do filname[i] := upcase(filname[i]);
end; { upc_filname }

procedure get_filnames(var filname,outfilname:filname_type;
                       var done,error:boolean);
var temp : filname_type;
begin
  filname:=''; outfilname:='';
  writeln;
  write('List procedures and functions on what file (CR to quit) ? ');
  readln(filname);
  writeln;
  if filname <> '' then
    begin
      upc_filname(filname);
      if (pos('.',filname)-1 > 0) then
        outfilname:=copy(filname,1,pos('.',filname)-1) + '.LST'
      else outfilname:=filname + '.LST';

      write('List to (CR to choose ',outfilname,', LPT1 for printer) ? ');
      readln(temp);
      if (temp <> '') then
        begin
          upc_filname(temp);
          outfilname:=temp;
        end;
      if outfilname=filname then
        begin
          writeln('ERROR >> The source, ',filname,' = the destination, ',outfilname);
          error:=true
        end;
    end { if filname <> '' then }
  else done:=true
end; { get_filename }

procedure open_file(var filname:filname_type;var fil:fil_type;var error:boolean);
begin
  {$I-}
  assign(fil,filname);
  reset(fil);
  {$I+}
  if ioResult <> 0 then
    begin
      error:=true;
      writeln('ERROR >> File does not exist');
   end;
end; { open_files }

procedure open_outfile(var outfilname:filname_type;var outfil:fil_type);
begin
    assign(outfil,outfilname);
    rewrite(outfil);
end;

procedure print_procfunc_list(var fil:fil_type;
                                  filname:filname_type);
var
  fil_lin : fil_lin_type;
  first_word : identifier_type;
  is_cont_lin : boolean;

  function is_procfunc(var fil_lin:fil_lin_type;
                       var is_cont_lin:boolean):boolean;


    procedure get_first_word(fil_lin:fil_lin_type;
                             var first_word:identifier_type);
    label return;
    var
      i, i2 : integer;
    begin { get_first_word }
      first_word:='';
      for i:=1 to length(fil_lin) do
        begin
          if fil_lin[i] <> ' ' then
            begin
              for i2:=i to length(fil_lin) do
                begin
                  if fil_lin[i2] <> ' ' then
                    first_word:=concat(first_word,upcase(fil_lin[i2]))
                  else
                    begin
                      goto return;
                    end; { else }
                end; { for }
            end; { if }
        end; { for }
      return:
    end; { get_first_word }

    procedure set_cont_flag(fil_lin:fil_lin_type;
                            first_word:identifier_type;
                            var is_cont_lin:boolean);
    begin { set_cont_flag }
      if (first_word = 'PROCEDURE') or
         (first_word = 'FUNCTION') or
         (first_word = 'PROGRAM') then
        if (pos('(',fil_lin) <> 0) and (pos(')',fil_lin) = 0) then
          is_cont_lin:=true;
    end; { set_cont_flag }

begin { is_procfunc }
  get_first_word(fil_lin,first_word);
  if not is_cont_lin then set_cont_flag(fil_lin, first_word,is_cont_lin);
  if (first_word = 'PROCEDURE') or
      (first_word = 'FUNCTION') or
      (first_word = 'PROGRAM') or
      (first_word = 'END.') or
      is_cont_lin then
        is_procfunc:=true
      else is_procfunc:=false;
end; { is_procfunc }

procedure clrsav_cont_flag(fil_lin:fil_lin_type;
                           var is_cont_lin:boolean);
begin { clrsav_cont_flag }
  if (pos(')',fil_lin) <> 0) then
    is_cont_lin := false;
end; { clrsav_cont_flag }

begin { print_procfunc_list }
  writeln('                              *** LISTSUBS ***');
  writeln;
  writeln('                  A list of subprograms for the file ',filname);
  writeln;
  writeln;
  writeln(outfil,'                              *** LISTSUBS ***');
  writeln(outfil);
  writeln(outfil,'                  A list of subprograms for the file ',filname);
  writeln(outfil);
  writeln(outfil);
  is_cont_lin:=false;
  while not eof(fil) do
    begin
      fil_lin:='';
      readln(fil,fil_lin);
      if is_procfunc(fil_lin,is_cont_lin) then
        begin
          writeln(fil_lin);
          writeln(outfil,fil_lin);
        end; { if }
      if is_cont_lin then clrsav_cont_flag(fil_lin,is_cont_lin);
  end; { while }
end; { print_procfunc_list }

begin { main program }
  done:=false;
  repeat
    error:=false;
    get_filnames(filname,outfilname,done,error);
    if (not done) and (not error) then
      begin
        open_file(filname,fil,error);
        if not error then
          begin
            open_outfile(outfilname,outfil);
            print_procfunc_list(fil,filname);
            close_files(fil,outfil);
          end;
      end { if (not done) and (not error) then }
  until done;
end. { listSubs }